home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / assem-opt.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  7.3 KB  |  229 lines
  1. ;;; -*- Package: ASSEMBLER; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: assem-opt.lisp,v 1.5 91/02/25 15:31:24 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    Assembly level optimization for the compiler.
  15. ;;;
  16. (defpackage "ASSEMBLER"
  17.   (:use "LISP" "EXTENSIONS" "C")
  18.   (:export "OPTIMIZE-SEGMENT")
  19.   (:import-from "C" "BACKEND-SB-LIST" "FINITE-SB-LIVE-TNS" "FINITE-SB"
  20.         "SC-ELEMENT-SIZE"))
  21. (in-package "ASSEMBLER")
  22.  
  23. ;;; DELETE-NODE  --  Internal
  24. ;;;
  25. ;;;    Delete a node from the assembly output.  Seg is the segment, so we can
  26. ;;; fix up the Last pointer.
  27. ;;;
  28. (defun delete-node (inst seg)
  29.   (declare (type node inst) (type segment seg))
  30.   (let ((prev (node-prev inst))
  31.     (next (node-next inst)))
  32.     (setf (node-next prev) next)
  33.     (cond (next (setf (node-prev next) prev))
  34.       (t
  35.        (assert (eq inst (segment-last seg)))
  36.        (setf (segment-last seg) prev)))))
  37.   (undefined-value))
  38.  
  39.  
  40. ;;; REPLACE-NODE  --  Internal
  41. ;;;
  42. ;;;    Replace Node with New, deleting Node.  Seg is the segment, so we can fix
  43. ;;; up the Last pointer.
  44. ;;;
  45. (defun replace-node (node new seg)
  46.   (declare (type node new new) (type segment seg))
  47.   (let ((prev (node-prev node))
  48.     (next (node-next node)))
  49.     (delete-node new seg)
  50.     (setf (node-prev new) prev)
  51.     (setf (node-next new) next)
  52.     (setf (node-next prev) new)
  53.     (cond (next (setf (node-prev next) new))
  54.       (t
  55.        (assert (eq node (segment-last seg)))
  56.        (setf (segment-last seg) new))))
  57.   (undefined-value))
  58.  
  59.  
  60. ;;; [NOT-]INST-CLASS-P  --  Internal
  61. ;;;
  62. ;;;    If Inst is an Instruction with some of the specified Attributes, then
  63. ;;; return T, otherwise NIL.  NOT-INST-CLASS-P is like (NOT (INST-CLASS-P ...))
  64. ;;; except that we still return NIL when INST is not an instruction.
  65. ;;;
  66. (defmacro inst-class-p (inst &rest attributes)
  67.   (once-only ((n-inst inst))
  68.     `(and (typep ,n-inst 'instruction)
  69.       (instruction-attributep (instruction-info-attributes
  70.                    (instruction-info ,n-inst))
  71.                   ,@attributes))))
  72. ;;;
  73. (defmacro not-inst-class-p (inst &rest attributes)
  74.   (once-only ((n-inst inst))
  75.     `(and (typep ,n-inst 'instruction)
  76.       (not (instruction-attributep (instruction-info-attributes
  77.                     (instruction-info ,n-inst))
  78.                        ,@attributes)))))
  79.  
  80.  
  81. ;;; PREV-INST, NEXT-INST  --  Internal
  82. ;;;
  83. ;;;    Return the next or previous instruction of Node, if we can determine
  84. ;;; this.  NIL if we can't tell.
  85. ;;;
  86. (declaim (inline next-inst prev-inst))
  87. (defun prev-inst (node)
  88.   (declare (type (or node null) node))
  89.   (when node
  90.     (let ((prev (node-prev node)))
  91.       (when (typep prev 'instruction) prev))))
  92. ;;;
  93. (defun next-inst (node)
  94.   (declare (type (or node null) node))
  95.   (when node
  96.     (do ((node (node-next node) (node-next node)))
  97.     (nil)
  98.       (typecase node
  99.     (instruction (return node))
  100.     (label)
  101.     (t (return nil))))))
  102.  
  103.  
  104. ;;; NOTE-TN-USED  --  Internal
  105. ;;;
  106. ;;;    Mark the locations for TN as being in use (thus prohibiting motion of
  107. ;;; code that also uses these locations.)
  108. ;;;
  109. (defun note-tn-used (tn clobber-p)
  110.   (let* ((sc (tn-sc tn))
  111.      (sb (sc-sb sc)))
  112.     (when (typep sb 'finite-sb)
  113.       (let ((live (finite-sb-live-tns sb)))
  114.     (loop for i from (tn-offset tn)
  115.           repeat (sc-element-size sc) do
  116.       (setf (svref live i)
  117.         (if clobber-p :clobber (or (svref live i) :use)))))))
  118.   (undefined-value))
  119.  
  120.  
  121. ;;; TN-USED-P  --  Internal
  122. ;;;
  123. ;;;    Return :USE, :CLOBBER or NIL, depending on how of TN's locations are
  124. ;;; currently used.
  125. ;;;
  126. (defun tn-used-p (tn)
  127.   (let* ((sc (tn-sc tn))
  128.      (sb (sc-sb sc)))
  129.     (when (typep sb 'finite-sb)
  130.       (let ((live (finite-sb-live-tns sb))
  131.         (res nil))
  132.     (loop for i from (tn-offset tn)
  133.           repeat (sc-element-size sc) do
  134.       (ecase (svref live i)
  135.         ((nil))
  136.         (:use (unless res (setq res :use)))
  137.         (:clobber (setq res :clobber))))
  138.     res))))
  139.  
  140.  
  141. ;;; FIND-DELAY-SUBJECT  --  Internal
  142. ;;;
  143. ;;;    Find an instruction that can be moved into the delay slot of Delay and
  144. ;;; return it, or NIL if we can't find any.  We scan backward for a preceding
  145. ;;; instruction that doesn't have any resource conflicts with any intervening
  146. ;;; instructions.  There is a resource conflict if:
  147. ;;;  -- Any used random resources are clobbered by subsequent instructions, or
  148. ;;;  -- Any clobbered random resources are used *or* clobbered by subsequent
  149. ;;;     instructions, or
  150. ;;;  -- Any arguments to the instruction are results of subsequent
  151. ;;;     instructions, or
  152. ;;;  -- Any results of the instruction are either arguments *or* results to
  153. ;;;     subsequent instructions.
  154. ;;;
  155. ;;; We also stop the scan whenever we hit a non-instruction (label or .align)
  156. ;;; or a pinned instruction.  The instruction must not be:
  157. ;;;  -- In a delay slot itself, or
  158. ;;;  -- The delayed instruction itself, or
  159. ;;;  -- An instruction with a delay slot itself, or
  160. ;;;  -- A no-op itself.
  161. ;;;
  162. ;;; We put an arbitrary upper bound of 20 on how far we scan back to avoid any
  163. ;;; potential quadratic blowup in large blocks.
  164. ;;;
  165. (defun find-delay-subject (delay)
  166.   (dolist (sb (backend-sb-list *backend*))
  167.     (when (typep sb 'finite-sb)
  168.       (fill (finite-sb-live-tns sb) nil)))
  169.   
  170.   (let ((used-resources 0)
  171.     (clobbered-resources 0))
  172.     (declare (type index used-resources))
  173.     (loop for inst = delay then (node-prev inst)
  174.           repeat 20 
  175.           while (typep inst 'instruction) do
  176.       (let* ((info (instruction-info inst))
  177.          (use (instruction-info-use info))
  178.          (clobber (instruction-info-clobber info)))
  179.     (unless (eq inst delay)
  180.       (when (instruction-info-pinned info)
  181.         (return nil))
  182.       (when (and (zerop (logand use clobbered-resources))
  183.              (zerop (logand clobber (logior used-resources
  184.                             clobbered-resources)))
  185.              (do-arguments (arg inst t)
  186.                (when (eq (tn-used-p arg) :clobber) (return nil)))
  187.              (do-results (res inst t)
  188.                (when (tn-used-p res) (return nil)))
  189.              (not-inst-class-p inst nop delayed-branch delayed-load)
  190.              (not-inst-class-p (prev-inst inst)
  191.                        delayed-branch delayed-load))
  192.         (return inst)))
  193.     
  194.     (do-results (res inst)
  195.       (note-tn-used res t))
  196.     (do-arguments (arg inst)
  197.       (note-tn-used arg nil))
  198.     (setq used-resources (logior use used-resources))
  199.     (setq clobbered-resources (logior clobber clobbered-resources))))))
  200.  
  201.  
  202. ;;; OPTIMIZE-SEGMENT  --  Public
  203. ;;;
  204. ;;;    Do assembly-level optimization on Seg.  Currently this consists solely
  205. ;;; of no-op elimination.
  206. ;;;
  207. (defun optimize-segment (seg)
  208.   (do ((current (node-next seg) (node-next current)))
  209.       ((null current))
  210.     (block NEXT
  211.       (when (inst-class-p current nop)
  212.     (let ((prev (prev-inst current)))
  213.       (when (and (inst-class-p prev delayed-load)
  214.              (not-inst-class-p (prev-inst prev) delayed-branch)) 
  215.         (let ((next (next-inst current)))
  216.           (when (and next
  217.              (block punt
  218.                (do-arguments (arg next t)
  219.                  (do-results (res prev)
  220.                    (when (location= arg res)
  221.                  (return-from punt nil))))))
  222.         (delete-node current seg)
  223.         (return-from NEXT))))
  224.       (when (inst-class-p prev delayed-branch delayed-load)
  225.         (let ((subj (find-delay-subject prev)))
  226.           (when subj
  227.         (replace-node current subj seg)
  228.         (return-from NEXT)))))))))
  229.